Software Vault: The Gold Collection/Software Vault - The Gold Collection (American Databankers) (1993).ISO/cdr48/btv115.zip/BTVTYPE.PAS

Pascal/Delphi Source File | 1993-04-01 | 23KB | 894 lines

{*
* ┌───────────────────────────────────────────────────────────────┐
* │ BTVTYPE.PAS  Version 1.0                                      │
* │                                                               │
* │ BTRIEVE data type conversion routines for Turbo Pascal 6.0.   │
* │                                                               │
* │ Copyright (c) 1992 by Richard W. Hansen, all rights reserved. │
* └───────────────────────────────────────────────────────────────┘
*
*
*  Requires Turbo Pascal version 6.0
*
*
*  Registration and payment of a license fee is required for any use, whether
*  in whole or part, of this source code.
*
*}

{****************************************************************************}
{*   REVISION HISTORY                                                       *}
{*                                                                          *}
{*  Date     Who  What                                                      *}
{* ======================================================================== *}
{* 06/05/92  RWH  First version.                                            *}
{****************************************************************************}

UNIT BTVType;
{$F-}
{$X+}
{$A-}
{$V-}


INTERFACE


TYPE
  BDateRec  = record
    Month : Byte;
    Day   : Byte;
    Year  : Word;
  end;


  BTimeRec  = record
    Hundred : Byte;
    Second  : Byte;
    Minute  : Byte;
    Hour    : Byte;
  end;


{
  This Unit includes routines to convert Btrieve data types to and from
  Pascal strings. Also included are routines for converting the BFloat types
  to Turbo Pascal Singles, and Doubles.

  These routines are intended to ease the use of the Btrieve data types.
  At first, some of them may seem redundant or of little use. They are
  designed primarily for use with raw data from Btrieve records. All the
  routines use untyped VAR parameters to handle the Btrieve types that are
  not defined in Pascal. Untyped VAR parameters get around Pascal's strict
  type checking, so you should exercise a bit more care calling these
  routines.

  A typical call to convert IEEE single to a string might be:

    St := FloatToStr(Buffer[10], 4, 10, 4);

  Notice how the untyped parameter lets you convert data from any part of a
  record buffer (though you could just as well have passed a variable of
  type single in this example). Most of the routines have a size parameter,
  in the example above it is the second parameter (4). The 4 indicates that
  we want to convert a 4 byte Single into a string.

  It is very important that you pass the correct size. The size always refers
  to the size of the Btrieve type and controls the type conversion (say to
  single or double) or the size of resulting data when converting from a
  string to a Btrieve type. If you specify the size incorrectly, you will
  get garbage results or overwrite other data in memory.

  There are a couple of conversion routines left out, string to time and
  string to date, and string to logical. The time and date did not seem
  worth the effort, given the variety of possible inputs.

  As a final note, if you use any of the routines for IEEE single or double
  types you will need to compile your program with the $N+ and $E+ compiler
  directives.
}


{* String to Data conversion routines *}

Function StrToInteger(    S    : String;
                      var Int;
                          Size : Byte): Boolean;

Function StrToUnsigned(    S    : String;
                       var Int;
                           Size : Byte): Boolean;

Procedure StrToLString(    S : String;
                       var Str);

Procedure StrToZString(    S : String;
                       var Str);

Function StrToFloat(    S    : String;
                    var Float;
                        Size : Byte): Boolean;

Procedure StrToString(    S : String;
                      var Str);

Function StrToBFloat(    S    : String;
                     var BFloat;
                         Size : Byte): Boolean;

Procedure StrToNumeric(    S    : String;
                       var Numeric;
                           Size : Byte);

Function StrToDecimal(    S    : String;
                      var Decimal;
                          Size : Byte): Boolean;
  { The sign, negatives only, must be in first position, i.e. -1111.00
    Make sure the decimal is big enough to hold the converted string!!!
  }



{* Data to string conversion routines *}

Function LogicalToStr(var Logical;
                          Size  : Byte): String;

Function IntegerToStr(var Int;
                          Size : Byte;
                          Width: Byte): String;

Function UnsignedToStr(var Int;
                           Size : Byte;
                           Width: Byte): String;

Function LStringToStr(var Str): String;

Function ZStringToStr(var Str): String;

Function TimeToStr(var Time): String;

Function DateToStr(var Date): String;

Function FloatToStr(var Float;
                        Size    : Byte;
                        Width   : Byte;
                        Decimals: Byte): String;

Function StringToStr(var Str;
                         Size : Byte): String;

Function DecimalToStr(var Decimal;
                          Size : Byte): String;

Function BFloatToStr(var BFloat;
                         Size    : Byte;
                         Width   : Byte;
                         Decimals: Byte): String;

Function NumericToStr(var Numeric;
                          Size   : Byte): String;



{* BFloat conversion routines *}

Function BFloatToSingle(var BFloat): Single;
  {- MS Single Precision (4 Byte) Float to TP IEEE Single }

Procedure SingleToBFloat(var BFloat;
                             Sgl   : Single);
  {- TP IEEE Single to MS Single Precision (4 Byte) Float }


Function BFloatToDouble(var BFloat): Double;
  {- MS Double precision (8 Byte) to TP IEEE Double }

Procedure DoubleToBFloat(var BFloat;
                             Dbl   : Double);
  {- TP IEEE Double to MS Double Precision (8 Byte) Float }



CONST
  DecimalPt : Char  = '.';

{============================================================================}
IMPLEMENTATION


TYPE
  Chars = Array[1..256] of Char;
  Bytes = Array[1..256] of Byte;


{--- BFloat Routines ---}

{***************************************************************************}
{ Turbo Pascal IEEE Single                                                  }
{                                                                           }
{ Byte  4      43        32      21      1                                  }
{  Bit  7 65432107 65432107654321076543210                                  }
{      +-+--------+----------------------+                                  }
{      |S| 8 bit  |                      |                                  }
{      |I|exponent| 23 bit mantissa      |                                  }
{      |G|        |                      |                                  }
{      |N|        |                      |                                  }
{      +-+--------+----------------------+                                  }
{***************************************************************************}
{ Microsoft Basic Single Precsion and Btrieve 4 Byte BFLOAT                 }
{                                                                           }
{ Byte  4      4 3       32      21      1                                  }
{  Bit  76543210 7 65432107654321076543210                                  }
{      +--------+-+----------------------+                                  }
{      | 8 bit  |S|                      |                                  }
{      |exponent|I| 23 bit mantissa      |                                  }
{      |        |G|                      |                                  }
{      |        |N|                      |                                  }
{      +--------+-+----------------------+                                  }
{***************************************************************************}

Function BFloatToSingle(var BFloat): Single;

  var
    Sign     : Byte;
    Exponent : Byte;
    Sgl      : Single;
    Byt      : Bytes Absolute Sgl;

  begin
    Sgl := Single(BFloat);
    Exponent := Byt[4];

    if (Exponent <> 0) then
    begin
      Sign := Byt[3] AND $80;
      { adjust the exponent bias }
      Exponent := Exponent - $81 + $7F;
      { reassemble  }
      Byt[4] := Sign OR (Exponent SHR 1);
      Byt[3] := Byt[3] OR (Exponent SHL 7);
    end;

    BFloatToSingle := Sgl;
  end;

Procedure SingleToBFloat(var BFloat;
                             Sgl : Single);

  var
    Sign     : Byte;
    Exponent : Byte;
    Byt      : Bytes Absolute BFloat;

  begin
    Single(BFloat) := Sgl;
    Exponent := (Byt[4] SHL 1) OR (Byt[3] SHR 7);

    if (Exponent <> 0) then
    begin
      Sign := Byt[4] AND $80;
      { adjust the exponent bias }
      Exponent := Exponent - $7F + $81;
      { reassemble  }
      Byt[4]   := Exponent;
      Byt[3]   := Sign OR Byt[3];
    end;
  end;

{***************************************************************************}
{ Turbo Pascal IEEE Double                                                  }
{                                                                           }
{ byte  8 ......87... ...76......65......54......43......32......21......1  }
{  bit  7 65432107654 3210765432107654321076543210765432107654321076543210  }
{      +-+-----------+---------------------------------------------------+  }
{      |S|           |                                                   |  }
{      |I| 11 bit    | 52 bit mantissa                                   |  }
{      |G| exponent  |                                                   |  }
{      |N|           |                                                   |  }
{      +-+-----------+---------------------------------------------------+  }
{***************************************************************************}
{ Microsoft Basic Double Precsion and Btrieve 8 Byte BFLOAT                 }
{                                                                           }
{ byte  8......8 7 7.....76......65......54......43......32......21......1  }
{  bit  76543210 7 6543210765432107654321076543210765432107654321076543210  }
{      +--------+-+------------------------------------------------------+  }
{      |        |S|                                                      |  }
{      |8 bit   |I| 55 bit mantissa                                      |  }
{      |exponent|G|                                                      |  }
{      |        |N|                                                      |  }
{      +--------+-+------------------------------------------------------+  }
{***************************************************************************}

Function BFloatToDouble(var BFloat): Double;

  var
    Dbl      : Array[1..8] of Byte;
    Exponent : Integer;
    Exp      : Array[1..2] of Byte Absolute Exponent;

  begin
    Exponent := BYTES(BFloat)[8];
    FillChar(Dbl, 8, 0);

    if (Exponent <> 0) then
    begin
      { change BIAS to 1023 }
      Exponent:= Exponent - 129 + 1023;
      Dbl[8]  := (BYTES(BFloat)[7] AND $80) + (Exp[1] SHR 4) + (Exp[2] SHL 4);
      Dbl[7]  := (Exp[1] SHL 4) + ((BYTES(BFloat)[7] and $7F) SHR 3);
      Dbl[6]  := (BYTES(BFloat)[7] SHL 5) + (BYTES(BFloat)[6] SHR 3);
      Dbl[5]  := (BYTES(BFloat)[6] SHL 5) + (BYTES(BFloat)[5] SHR 3);
      Dbl[4]  := (BYTES(BFloat)[5] SHL 5) + (BYTES(BFloat)[4] SHR 3);
      Dbl[3]  := (BYTES(BFloat)[4] SHL 5) + (BYTES(BFloat)[3] SHR 3);
      Dbl[2]  := (BYTES(BFloat)[3] SHL 5) + (BYTES(BFloat)[2] SHR 3);
      Dbl[1]  := (BYTES(BFloat)[2] SHL 5) + (BYTES(BFloat)[1] SHR 3);
    end;

    BFloatToDouble  := Double(Dbl);
  end;

Procedure DoubleToBFloat(var BFloat;
                             Dbl : Double);
  var
    Exponent : Integer;
    Byt      : Bytes Absolute Dbl;

  begin
    Exponent := Byt[8] AND $7F;
    Exponent := (Exponent SHL 4) + (Byt[7] shr 4);
    FillChar(BYTES(BFloat), 8, 0);

    if (Exponent <> 0) then
    begin
      { change BIAS to 129 }
      Exponent := Exponent - 1023 + 129;
      BYTES(BFloat)[8] := Exponent;
      BYTES(BFloat)[7] := (Byt[8] and $80) + ((Byt[7] and $0F) SHL 3) + (Byt[6] SHR 5);
      BYTES(BFloat)[6] := (Byt[6] SHL 3) + (Byt[5] SHR 5);
      BYTES(BFloat)[5] := (Byt[5] SHL 3) + (Byt[4] SHR 5);
      BYTES(BFloat)[4] := (Byt[4] SHL 3) + (Byt[3] SHR 5);
      BYTES(BFloat)[3] := (Byt[3] SHL 3) + (Byt[2] SHR 5);
      BYTES(BFloat)[2] := (Byt[2] SHL 3) + (Byt[1] SHR 5);
      BYTES(BFloat)[1] := (Byt[1] SHL 3);
    end;
  end;

Function BFloatToStr(var BFloat;
                         Size    : Byte;
                         Width   : Byte;
                         Decimals: Byte): String;

  var
    S : String;

  begin
    Case Size of
      4 : Str(BFloatToSingle(BFloat):Width:Decimals, S);
      8 : Str(BFloatToDouble(BFloat):Width:Decimals, S);
      else
        S := 'ERROR';
    end;

    BFloatToStr := S;
  end;

Function StrToBFloat(    S    : String;
                     var BFloat;
                         Size : Byte): Boolean;

  var
    Err : Integer;
    Sgl : Single;
    Dbl : Double;

  begin

    Case Size of
      4 :
      begin
        Val(S, Sgl, Err);

        if (Err = 0) then
          SingleToBFloat(BFloat, Sgl);
      end;
      8 :
      begin
        Val(S, Dbl, Err);

        if (Err = 0) then
          DoubleToBFloat(BFloat, Dbl);
      end;
    end;

    StrToBFloat := (Err = 0);
  end;


{--- Integer Routines ---}

Function IntegerToStr(var Int;
                          Size : Byte;
                          Width: Byte): String;

  var
    S : String[30];

  begin
    Case Size of
      2 : Str(INTEGER(Int):Width, S);
      4 : Str(LONGINT(Int):Width, S);
      else
        S := 'ERROR';
    end;

    IntegerToStr := S;
  end;

Function StrToInteger(    S    : String;
                      var Int;
                          Size : Byte): Boolean;

  var
    Err : Integer;

  begin
    Case Size of
      2 : Val(S, INTEGER(Int), Err);
      4 : Val(S, LONGINT(Int), Err);
    end;

    StrToInteger := (Err = 0);
  end;


{--- Unsigned Routines ---}

Function UnsignedToStr(var Int;
                           Size : Byte;
                           Width: Byte): String;

  var
    S : String[30];

  begin
    Case Size of
      1 : Str(BYTE(Int):Width, S);
      2 : Str(WORD(Int):Width, S);
      4 : Str(LONGINT(Int):Width, S);
      else
        S := 'ERROR';
    end;

    UnsignedToStr := S;
  end;

Function StrToUnsigned(    S    : String;
                       var Int;
                           Size : Byte): Boolean;

  var
    Err : Integer;

  begin
    Case Size of
      1 : Val(S, BYTE(Int), Err);
      2 : Val(S, INTEGER(Int), Err);
      4 : Val(S, LONGINT(Int), Err);
    end;

    StrToUnsigned := (Err = 0);
  end;


{--- LString Routines ---}

Function LStringToStr(var Str): String;

  var
    S : String;

  begin
    Move(CHARS(Str), S[0], BYTE(Str) + 1);
    LStringToStr := S;
  end;

Procedure StrToLString(    S : String;
                       var Str);
  begin
    Move(S[0], Str, BYTE(S[0]) + 1);
  end;


{--- ZString Routines ---}

Function ZStringToStr(var Str): String;

  var
    i : Byte;
    S : String;

  begin
    i := 0;

    While (CHARS(Str)[i+1] <> #0) and (i < 255) do
    begin
      Inc(i);
      S[i] := CHARS(Str)[i];
    end;

    BYTE(S[0]) := i;
    ZStringToStr := S;
  end;

Procedure StrToZString(    S : String;
                       var Str);
  begin
    Move(S[1], Str, BYTE(S[0]));
    CHARS(Str)[BYTE(S[0])+1] := #0;
  end;


{--- Time Routines ---}

Function TimeToStr(var Time): String;

  var
    S : String[30];
    X : String[2];
    i : Byte;
    T : BTimeRec Absolute Time;

  begin
    Str(T.Hour:2, S);
    S := S + ':';
    Str(T.Minute:2, X);
    S := S + X + ':';
    Str(T.Second:2, X);
    S := S + X + ':';
    Str(T.Hundred:2, X);
    S := S + X;

    for i := 1 to Length(S) do
      if S[i] = ' ' then
        S[i] := '0';

    TimeToStr := S;
  end;


{--- Date Routines ---}

Function DateToStr(var Date): String;

  var
    S : String[30];
    X : String[4];
    i : Byte;
    D : BDateRec Absolute Date;

  begin
    Str(D.Month:2, S);
    S := S + '/';
    Str(D.Day:2, X);
    S := S + X + '/';

    if (D.Year > 100) then
      Str(D.Year:4, X)
    else
      Str(D.Year:2, X);

    S := S + X;

    for i := 1 to Length(S) do
      if S[i] = ' ' then
        S[i] := '0';

    DateToStr := S;
  end;


{--- Float Routines ---}

Function FloatToStr(var Float;
                        Size    : Byte;
                        Width   : Byte;
                        Decimals: Byte): String;

  var
    S   : String;

  begin
    Case Size of
      4 : Str(SINGLE(Float):Width:Decimals, S);
      8 : Str(DOUBLE(Float):Width:Decimals, S);
      else
        S := 'ERROR';
    end;

    FloatToStr := S;
  end;

Function StrToFloat(    S    : String;
                    var Float;
                        Size : Byte): Boolean;

  var
    Err : Integer;

  begin
    Case Size of
      4 : Val(S, SINGLE(Float), Err);
      8 : Val(S, DOUBLE(Float), Err);
    end;

    StrToFloat := (Err = 0);
  end;


{--- String Routines ---}

Function StringToStr(var Str;
                         Size : Byte): String;

  var
    S : String;

  begin
    if (Size > 255) then
      Size := 255;

    Move(CHARS(Str), S[1], Size);
    BYTE(S[0])  := Size;
    StringToStr := S;
  end;

Procedure StrToString(    S : String;
                      var Str);

  begin
    Move(S[1], Str, Length(S));
  end;



{--- Decimal Routines ---}

Function DecimalToStr(var Decimal;
                          Size : Byte): String;

  var
    D     : Bytes Absolute Decimal;
    Sign  : Char;
    i     : Byte;
    S     : String;

  begin
    { extract sign }
    if ((D[Size] AND $0F) = $0D) then
      Sign := '-'
    else
      Sign := ' ';

    i := 1;
    S := '';

    While (i < Size) do
    begin
      { high nibble Digit }
      S := S + Chr(((D[i] AND $F0) Shr 4) + 48);
      { low nibble Digit  }
      S := S + Chr((D[i] AND $0F) + 48);
      Inc(i);
    end;

    { sign nibble }
    S := S + Chr(((D[Size] AND $F0) Shr 4) + 48);

    { trim leading zeros }
    i := 0;

    While (i < Length(S)) and (S[i + 1] = '0') do
      Inc(i);

    if (i > 1) then
    begin
      Move(S[i + 1], S[1], Length(S) - i);
      BYTE(S[0]) := Length(S) - i;
    end;

    if (S = '') then
      S := '0';

    if (S <> '0') and (Sign <> ' ') then
      S := Sign + S;

    DecimalToStr := S;
  end;

Function StrToDecimal(    S    : String;
                      var Decimal;
                          Size : Byte): Boolean;

  var
    D : Bytes Absolute Decimal;
    i : Byte;
    j : Byte;
    Err : Boolean;

  Procedure NextDigit(Shift : Boolean);
    begin
      if (S[j] >= '0') and (S[j] <= '9') then
      begin
        if Shift then
          D[i] := D[i] OR ((BYTE(S[j]) - 48) Shl 4)
        else
          D[i] := D[i] OR (BYTE(S[j]) - 48);
      end

      else if (S[j] <> DecimalPt) then
      begin
        Err := True;
      end;
    end;

  begin
    FillChar(Decimal, Size, 0);
    Err := False;

    if (S[1] = '-') then
    begin
      D[Size] := $0D;
      Delete(S, 1, 1);
    end

    else
    begin
      D[Size] := $0C;
    end;

    j := Length(S);
    i := Size;
    NextDigit(True);
    Dec(j);
    Dec(i);

    While (i > 0) and (j > 0) do
    begin
      NextDigit(False);
      Dec(j);

      if (j > 0) then
      begin
        NextDigit(True);
        Dec(j);
      end;

      Dec(i);
    end;

    StrToDecimal := Err;
  end;



{--- Numeric Routines ---}

Function NumericToStr(var Numeric;
                          Size : Byte): String;

  var
    S    : String;

  begin
    Move(Numeric, S[1], Size);
    BYTE(S[0]) := Size;

    Case S[Size] of
      'J'..'R', '}' : S := '-' + S;
    end;

    Case S[Length(S)] of
      'A','J' : S[Size] := '1';
      'B','K' : S[Size] := '2';
      'C','L' : S[Size] := '3';
      'D','M' : S[Size] := '4';
      'E','N' : S[Size] := '5';
      'F','O' : S[Size] := '6';
      'G','P' : S[Size] := '7';
      'H','Q' : S[Size] := '8';
      'I','R' : S[Size] := '9';
      '{','}' : S[Size] := '0';
    end;

    NumericToStr := S;
  end;

Procedure StrToNumeric(    S    : String;
                       var Numeric;
                           Size : Byte);

  var
    i : Byte;

  begin
    Case S[1] of
      '-' :
        begin
          Delete(S, 1,1);

          Case S[Length(S)] of
            '1' : S[Length(S)] := 'J';
            '2' : S[Length(S)] := 'K';
            '3' : S[Length(S)] := 'L';
            '4' : S[Length(S)] := 'M';
            '5' : S[Length(S)] := 'N';
            '6' : S[Length(S)] := 'O';
            '7' : S[Length(S)] := 'P';
            '8' : S[Length(S)] := 'Q';
            '9' : S[Length(S)] := 'R';
            '0' : S[Length(S)] := '}';
          end;
        end;

      '+' :
        begin
          Delete(S, 1,1);

          Case S[Length(S)] of
            '1' : S[Length(S)] := 'A';
            '2' : S[Length(S)] := 'B';
            '3' : S[Length(S)] := 'C';
            '4' : S[Length(S)] := 'D';
            '5' : S[Length(S)] := 'E';
            '6' : S[Length(S)] := 'F';
            '7' : S[Length(S)] := 'G';
            '8' : S[Length(S)] := 'H';
            '9' : S[Length(S)] := 'I';
            '0' : S[Length(S)] := '{';
          end;
        end;
    end;

    if (Length(S) < Size) then
    begin
      for i := 1 to Size - Length(S) do
        Insert('0', S, 1);
    end;

    Move(S[1], Numeric, Length(S));
  end;


Function LogicalToStr(var Logical;
                          Size  : Byte): String;

  var
    B : Byte Absolute Logical;
    W : Word Absolute Logical;

  begin
    if (Size = 1) then
    begin
      if (B = 0) then
        LogicalToStr := 'FALSE'
      else
        LogicalToStr := 'TRUE '
    end

    else if (Size = 2) then
    begin
      if (W = 0) then
        LogicalToStr := 'FALSE'
      else
        LogicalToStr := 'TRUE '
    end

    else
    begin
      LogicalToStr := 'ERROR';
    end;
  end;


END.